home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / hyper-apropos.el.z / hyper-apropos.el
Encoding:
Text File  |  1998-05-21  |  46.6 KB  |  1,311 lines
  1. ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
  2.  
  3. ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
  4. ;; Copyright (C) 1995 Sun Microsystems.
  5. ;; Copyright (C) 1996 Ben Wing.
  6.  
  7. ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
  8. ;; Keywords: lisp, tools, help, docs, matching
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2 of the License, or
  15. ;; (at your option) any later version.
  16. ;; 
  17. ;; XEmacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21. ;; 
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; if not, write to the Free Software
  24. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; Synched up with: Not in FSF.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;;  based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
  31. ;;
  32. ;;  Rather than run apropos and print all the documentation at once,
  33. ;;  I find it easier to view a "table of contents" first, then
  34. ;;  get the details for symbols as you need them.
  35. ;;
  36. ;;  This version of apropos prints two lists of symbols matching the
  37. ;;  given regexp:  functions/macros and variables/constants.
  38. ;;
  39. ;;  The user can then do the following:
  40. ;;
  41. ;;      - add an additional regexp to narrow the search
  42. ;;      - display documentation for the current symbol
  43. ;;      - find the tag for the current symbol
  44. ;;      - show any keybindings if the current symbol is a command
  45. ;;    - invoke functions
  46. ;;    - set variables
  47. ;;
  48. ;;  An additional feature is the ability to search the current tags
  49. ;;  table, allowing you to interrogate functions not yet loaded (this
  50. ;;  isn't available with the standard package).
  51. ;;
  52. ;;  Mouse bindings and menus are provided for XEmacs.
  53. ;;
  54. ;; additions by Ben Wing <wing@666.com> July 1995:
  55. ;; added support for function aliases, made programmer's apropos be the
  56. ;; default, various other hacking.
  57. ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
  58. ;; Some changes for XEmacs 20.3 by hniksic
  59.  
  60. ;; ### The maintainer is supposed to be stig, but I haven't seen him
  61. ;; around for ages.  The real maintainer for the moment is Hrvoje
  62. ;; Niksic <hniksic@srce.hr>.
  63.  
  64. ;;; Code:
  65.  
  66. (require 'pp)
  67.  
  68. (defgroup hyper-apropos nil
  69.   "Hypertext emacs lisp documentation interface."
  70.   :group 'docs
  71.   :group 'lisp
  72.   :group 'tools
  73.   :group 'help
  74.   :group 'matching)
  75.  
  76. (defcustom hyper-apropos-show-brief-docs t
  77.   "*If non-nil, display some documentation in the \"*Hyper Apropos*\" buffer.
  78. Setting this to nil will speed up searches."
  79.   :type 'boolean
  80.   :group 'hyper-apropos)
  81. (define-obsolete-variable-alias
  82.   'hypropos-show-brief-docs 'hyper-apropos-show-brief-docs)
  83. ;; I changed this to true because I think it's more useful this way. --ben
  84.  
  85. (defcustom hyper-apropos-programming-apropos t
  86.   "*If non-nil, list all the functions and variables.
  87. This will cause more output to be generated, and take a longer time.
  88.  
  89. Otherwise, only the interactive functions and user variables will be listed."
  90.   :type 'boolean
  91.   :group 'hyper-apropos)
  92. (define-obsolete-variable-alias
  93.   'hypropos-programming-apropos 'hyper-apropos-programming-apropos)
  94.  
  95. (defcustom hyper-apropos-shrink-window nil
  96.   "*If non-nil, shrink *Hyper Help* buffer if possible."
  97.   :type 'boolean
  98.   :group 'hyper-apropos)
  99. (define-obsolete-variable-alias
  100.   'hypropos-shrink-window 'hyper-apropos-shrink-window)
  101.  
  102. (defcustom hyper-apropos-prettyprint-long-values t
  103.   "*If non-nil, then try to beautify the printing of very long values."
  104.   :type 'boolean
  105.   :group 'hyper-apropos)
  106. (define-obsolete-variable-alias
  107.   'hypropos-prettyprint-long-values 'hyper-apropos-prettyprint-long-values)
  108.  
  109. (defgroup hyper-apropos-faces nil
  110.   "Faces defined by hyper-apropos."
  111.   :prefix "hyper-apropos-"
  112.   :group 'faces)
  113.  
  114. (defface hyper-apropos-documentation
  115.   '((((class color) (background light))
  116.      (:foreground "darkred"))
  117.     (((class color) (background dark))
  118.      (:foreground "gray90")))
  119.   "Hyper-apropos documentation."
  120.   :group 'hyper-apropos-faces)
  121.  
  122. (defface hyper-apropos-hyperlink
  123.   '((((class color) (background light))
  124.      (:foreground "blue4"))
  125.     (((class color) (background dark))
  126.      (:foreground "lightseagreen"))
  127.     (t
  128.      (:bold t)))
  129.   "Hyper-apropos hyperlinks."
  130.   :group 'hyper-apropos-faces)
  131.  
  132. (defface hyper-apropos-major-heading '((t (:bold t)))
  133.   "Hyper-apropos major heading."
  134.   :group 'hyper-apropos-faces)
  135.  
  136. (defface hyper-apropos-section-heading '((t (:bold t :italic t)))
  137.   "Hyper-apropos section heading."
  138.   :group 'hyper-apropos-faces)
  139.  
  140. (defface hyper-apropos-heading '((t (:bold t)))
  141.   "Hyper-apropos heading."
  142.   :group 'hyper-apropos-faces)
  143.  
  144. (defface hyper-apropos-warning '((t (:bold t :foreground "red")))
  145.   "Hyper-apropos warning."
  146.   :group 'hyper-apropos-faces)
  147.  
  148. ;;; Internal variables below this point
  149.  
  150. (defvar hyper-apropos-ref-buffer)
  151. (defvar hyper-apropos-prev-wconfig)
  152.  
  153. (defvar hyper-apropos-help-map
  154.   (let ((map (make-sparse-keymap)))
  155.     (suppress-keymap map)
  156.     (set-keymap-name map 'hyper-apropos-help-map)
  157.     ;; movement
  158.     (define-key map " "     'scroll-up)
  159.     (define-key map "b"     'scroll-down)
  160.     (define-key map [delete] 'scroll-down)
  161.     (define-key map [backspace] 'scroll-down)
  162.     (define-key map "/"     'isearch-forward)
  163.     (define-key map "?"     'isearch-backward)
  164.     ;; follow links
  165.     (define-key map [return] 'hyper-apropos-get-doc)
  166.     (define-key map "s"     'hyper-apropos-set-variable)
  167.     (define-key map "t"     'hyper-apropos-find-tag)
  168.     (define-key map "l"     'hyper-apropos-last-help)
  169.     (define-key map "c"     'hyper-apropos-customize-variable)
  170.     (define-key map "f"     'hyper-apropos-find-function)
  171.     (define-key map [button2] 'hyper-apropos-mouse-get-doc)
  172.     (define-key map [button3] 'hyper-apropos-popup-menu)
  173.     ;; for the totally hardcore...
  174.     (define-key map "D"     'hyper-apropos-disassemble)
  175.     ;; administrativa
  176.     (define-key map "a"     'hyper-apropos)
  177.     (define-key map "n"     'hyper-apropos)
  178.     (define-key map "q"     'hyper-apropos-quit)
  179.     map)
  180.   "Keybindings for the *Hyper Help* buffer and the *Hyper Apropos* buffer")
  181. (define-obsolete-variable-alias
  182.   'hypropos-help-map 'hyper-apropos-help-map)
  183.  
  184. (defvar hyper-apropos-map
  185.   (let ((map (make-sparse-keymap)))
  186.     (set-keymap-name map 'hyper-apropos-map)
  187.     (set-keymap-parents map (list hyper-apropos-help-map))
  188.     ;; slightly different scrolling...
  189.     (define-key map " "     'hyper-apropos-scroll-up)
  190.     (define-key map "b"     'hyper-apropos-scroll-down)
  191.     (define-key map [delete] 'hyper-apropos-scroll-down)
  192.     (define-key map [backspace] 'hyper-apropos-scroll-down)
  193.     ;; act on the current line...
  194.     (define-key map "w"     'hyper-apropos-where-is)
  195.     (define-key map "i"     'hyper-apropos-invoke-fn)
  196. ;; this is already defined in the parent-keymap above, isn't it?
  197. ;;     (define-key map "s"     'hyper-apropos-set-variable)
  198.     ;; more administrativa...
  199.     (define-key map "P"     'hyper-apropos-toggle-programming-flag)
  200.     (define-key map "k"     'hyper-apropos-add-keyword)
  201.     (define-key map "e"     'hyper-apropos-eliminate-keyword)
  202.     map)
  203.   "Keybindings for the *Hyper Apropos* buffer.
  204. This map inherits from `hyper-apropos-help-map.'")
  205. (define-obsolete-variable-alias
  206.   'hypropos-map 'hyper-apropos-map)
  207.  
  208. ;;(defvar hyper-apropos-mousable-keymap
  209. ;;  (let ((map (make-sparse-keymap)))
  210. ;;    (define-key map [button2] 'hyper-apropos-mouse-get-doc)
  211. ;;    map))
  212.  
  213. (defvar hyper-apropos-mode-hook nil
  214.   "*User function run after hyper-apropos mode initialization.  Usage:
  215. \(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")
  216.  
  217. ;; ---------------------------------------------------------------------- ;;
  218.  
  219. (defconst hyper-apropos-junk-regexp
  220.   "^Apropos\\|^Functions\\|^Variables\\|^$")
  221.  
  222. (defvar hyper-apropos-currently-showing nil)    ; symbol documented in
  223.                         ; help buffer now
  224. (defvar hyper-apropos-help-history nil)    ; chain of symbols followed as links in
  225.                     ; help buffer
  226. (defvar hyper-apropos-face-history nil)
  227. ;;;(defvar hyper-apropos-variable-history nil)
  228. ;;;(defvar hyper-apropos-function-history nil)
  229. (defvar hyper-apropos-regexp-history nil)
  230. (defvar hyper-apropos-last-regexp nil)    ; regex used for last apropos
  231. (defconst hyper-apropos-apropos-buf "*Hyper Apropos*")
  232. (defconst hyper-apropos-help-buf "*Hyper Help*")
  233.  
  234. ;;;###autoload
  235. (defun hyper-apropos (regexp toggle-apropos)
  236.   "Display lists of functions and variables matching REGEXP
  237. in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the
  238. value of `hyper-apropos-programming-apropos' is toggled for this search.
  239. See also `hyper-apropos-mode'."
  240.   (interactive (list (read-from-minibuffer "List symbols matching regexp: "
  241.                        nil nil nil 'hyper-apropos-regexp-history)
  242.              current-prefix-arg))
  243.   (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
  244.       (setq hyper-apropos-prev-wconfig (current-window-configuration)))
  245.   (if (string= "" regexp)
  246.       (if (get-buffer hyper-apropos-apropos-buf)
  247.       (if toggle-apropos
  248.           (hyper-apropos-toggle-programming-flag)
  249.         (message "Using last search results"))
  250.     (error "Be more specific..."))
  251.     (set-buffer (get-buffer-create hyper-apropos-apropos-buf))
  252.     (setq buffer-read-only nil)
  253.     (erase-buffer)
  254.     (if toggle-apropos
  255.     (set (make-local-variable 'hyper-apropos-programming-apropos)
  256.          (not (default-value 'hyper-apropos-programming-apropos))))
  257.     (let ((flist (apropos-internal regexp
  258.                    (if hyper-apropos-programming-apropos
  259.                        #'fboundp
  260.                      #'commandp)))
  261.       (vlist (apropos-internal regexp
  262.                    (if hyper-apropos-programming-apropos
  263.                        #'boundp
  264.                      #'user-variable-p))))
  265.       (insert-face (format "Apropos search for: %S\n\n" regexp)
  266.            'hyper-apropos-major-heading)
  267.       (insert-face "* = command (M-x) or user-variable.\n"
  268.            'hyper-apropos-documentation)
  269.       (insert-face "\
  270. a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n"
  271.            'hyper-apropos-documentation)
  272.       (insert-face "Functions and Macros:\n\n" 'hyper-apropos-major-heading)
  273.       (hyper-apropos-grok-functions flist)
  274.       (insert-face "\n\nVariables and Constants:\n\n"
  275.            'hyper-apropos-major-heading)
  276.       (hyper-apropos-grok-variables vlist)
  277.       (goto-char (point-min))))
  278.   (switch-to-buffer hyper-apropos-apropos-buf)
  279.   (hyper-apropos-mode regexp))
  280.  
  281. (defun hyper-apropos-toggle-programming-flag ()
  282.   (interactive)
  283.   (with-current-buffer hyper-apropos-apropos-buf
  284.     (set (make-local-variable 'hyper-apropos-programming-apropos)
  285.      (not hyper-apropos-programming-apropos)))
  286.   (message "Re-running apropos...")
  287.   (hyper-apropos hyper-apropos-last-regexp nil))
  288.  
  289. (defun hyper-apropos-grok-functions (fns)
  290.   (let (bind doc type)
  291.     (dolist (fn fns)
  292.       (setq bind (symbol-function fn)
  293.         type (cond ((subrp bind) ?i)
  294.                ((compiled-function-p bind) ?b)
  295.                ((consp bind) (or (cdr
  296.                       (assq (car bind) '((autoload . ?a)
  297.                                  (lambda . ?l)
  298.                                  (macro . ?m))))
  299.                      ??))
  300.                (t ?\ )))
  301.       (insert type (if (commandp fn) "* " "  "))
  302.       (let ((e (insert-face (format "%S" fn) 'hyper-apropos-hyperlink)))
  303.     (set-extent-property e 'mouse-face 'highlight))
  304.       (insert-char ?\  (let ((l (- 30 (length (format "%S" fn)))))
  305.              (if (natnump l) l 0)))
  306.       (and hyper-apropos-show-brief-docs
  307.        (setq doc
  308.        ;; A symbol's function slot can point to an unbound symbol.
  309.        ;; In that case, `documentation' will fail.
  310.          (ignore-errors
  311.            (documentation fn)))
  312.        (if  (string-match
  313.          "^([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
  314.          doc)
  315.            (setq doc (substring doc (match-end 0) (string-match "\n" doc)))
  316.          t)
  317.        (insert-face (if doc
  318.                 (concat " - "
  319.                     (substring doc 0 (string-match "\n" doc)))
  320.               " Not documented.")
  321.             'hyper-apropos-documentation))
  322.       (insert ?\n))))
  323.  
  324. (defun hyper-apropos-grok-variables (vars)
  325.   (let (doc userp)
  326.     (dolist (var vars)
  327.       (setq userp (user-variable-p var))
  328.       (insert (if userp " * " "   "))
  329.       (let ((e (insert-face (format "%S" var) 'hyper-apropos-hyperlink)))
  330.     (set-extent-property e 'mouse-face 'highlight))
  331.       (insert-char ?\  (let ((l (- 30 (length (format "%S" var)))))
  332.              (if (natnump l) l 0)))
  333.       (and hyper-apropos-show-brief-docs
  334.        (setq doc (documentation-property var 'variable-documentation))
  335.        (insert-face (if doc
  336.                 (concat " - " (substring doc (if userp 1 0)
  337.                              (string-match "\n" doc)))
  338.               " - Not documented.")
  339.             'hyper-apropos-documentation))
  340.       (insert ?\n))))
  341.  
  342. ;; ---------------------------------------------------------------------- ;;
  343.  
  344. (defun hyper-apropos-mode (regexp)
  345.   "Improved apropos mode for displaying Emacs documentation.  Function and
  346. variable names are displayed in the buffer \"*Hyper Apropos*\".  
  347.  
  348. Functions are preceded by a single character to indicates their types:
  349.     a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
  350. Interactive functions are also preceded by an asterisk.
  351. Variables are preceded by an asterisk if they are user variables.
  352.  
  353. General Commands:
  354.  
  355.       SPC    - scroll documentation or apropos window forward
  356.         b    - scroll documentation or apropos window backward
  357.       k     - eliminate all hits that don't contain keyword
  358.       n    - new search
  359.         /    - isearch-forward
  360.         q    - quit and restore previous window configuration
  361.   
  362.   Operations for Symbol on Current Line:
  363.   
  364.           RET     - toggle display of symbol's documentation
  365.           (also on button2 in xemacs)
  366.         w     - show the keybinding if symbol is a command
  367.         i    - invoke function on current line
  368.         s    - set value of variable on current line
  369.       t    - display the C or lisp source (find-tag)"
  370.   (delete-other-windows)
  371.   (setq mode-name "Hyper-Apropos"
  372.     major-mode 'hyper-apropos-mode
  373.     buffer-read-only t
  374.     truncate-lines t
  375.     hyper-apropos-last-regexp regexp
  376.     modeline-buffer-identification
  377.     (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
  378.           (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
  379.   (use-local-map hyper-apropos-map)
  380.   (run-hooks 'hyper-apropos-mode-hook))
  381.  
  382. ;; ---------------------------------------------------------------------- ;;
  383.  
  384. ;; similar to `describe-key-briefly', copied from prim/help.el by CW
  385.  
  386. ;;;###autoload
  387. (defun hyper-describe-key (key)
  388.   (interactive "kDescribe key: ")
  389.   (hyper-describe-key-briefly key t))
  390.  
  391. ;;;###autoload
  392. (defun hyper-describe-key-briefly (key &optional show)
  393.   (interactive "kDescribe key briefly: \nP")
  394.   (let (menup defn interm final msg)
  395.     (setq defn (key-or-menu-binding key 'menup))    
  396.     (if (or (null defn) (integerp defn))
  397.         (or (numberp show) (message "%s is undefined" (key-description key)))
  398.       (cond ((stringp defn)
  399.          (setq interm defn
  400.            final (key-binding defn)))
  401.         ((vectorp defn)
  402.          (setq interm (append defn nil))
  403.          (while (and interm
  404.              (member (key-binding (vector (car interm)))
  405.                  '(universal-argument digit-argument)))
  406.            (setq interm (cdr interm)))
  407.          (while (and interm
  408.              (not (setq final (key-binding (vconcat interm)))))
  409.            (setq interm (butlast interm)))
  410.          (if final
  411.          (setq interm (vconcat interm))
  412.            (setq interm defn 
  413.              final (key-binding defn)))))
  414.       (setq msg (format
  415.          "%s runs %s%s%s"
  416.          ;; This used to say 'This menu item' but it could also
  417.          ;; be a scrollbar event.  We can't distinguish at the
  418.          ;; moment.
  419.          (if menup "This item" (key-description key))
  420.          ;;(if (symbolp defn) defn (key-description defn))
  421.          (if (symbolp defn) defn (prin1-to-string defn))
  422.          (if final (concat ", " (key-description interm) " runs ") "")
  423.          (if final
  424.              (if (symbolp final) final (prin1-to-string final))
  425.            "")))
  426.       (if (numberp show)
  427.       (or (not (symbolp defn))
  428.           (memq (symbol-function defn)
  429.             '(zkey-init-kbd-macro zkey-init-kbd-fn))
  430.           (progn (princ msg) (princ "\n")))
  431.     (message "%s" msg)
  432.     (if final (setq defn final))
  433.     (if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn))))
  434.          defn
  435.          show)
  436.         (hyper-apropos-get-doc defn t))))))
  437.  
  438. ;;;###autoload
  439. (defun hyper-describe-face (symbol &optional this-ref-buffer)
  440.   "Describe face..
  441. See also `hyper-apropos' and `hyper-describe-function'."
  442.   ;; #### - perhaps a prefix arg should suppress the prompt...
  443.   (interactive
  444.    (let (v val)
  445.      (setq v (hyper-apropos-this-symbol))    ; symbol under point
  446.      (or (find-face v)
  447.      (setq v (variable-at-point)))
  448.      (setq val (let ((enable-recursive-minibuffers t))
  449.                  (completing-read
  450.           (concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
  451.                   "Follow face"
  452.                 "Describe face")
  453.               (if v
  454.                   (format " (default %s): " v)
  455.                 ": "))
  456.           (mapcar (function (lambda (x) (list (symbol-name x))))
  457.               (face-list))
  458.           nil t nil 'hyper-apropos-face-history)))
  459.      (list (if (string= val "")
  460.            (progn (push (symbol-name v) hyper-apropos-face-history) v)
  461.          (intern-soft val))
  462.        current-prefix-arg)))
  463.   (if (null symbol)
  464.       (message "Sorry, nothing to describe.")
  465.     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
  466.     (setq hyper-apropos-prev-wconfig (current-window-configuration)))
  467.     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
  468.  
  469. ;;;###autoload
  470. (defun hyper-describe-variable (symbol &optional this-ref-buffer)
  471.   "Hypertext drop-in replacement for `describe-variable'.
  472. See also `hyper-apropos' and `hyper-describe-function'."
  473.   ;; #### - perhaps a prefix arg should suppress the prompt...
  474.   (interactive (list (hyper-apropos-read-variable-symbol
  475.               (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
  476.               "Follow variable"
  477.             "Describe variable"))
  478.              current-prefix-arg))
  479.   (if (null symbol)
  480.       (message "Sorry, nothing to describe.")
  481.     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
  482.     (setq hyper-apropos-prev-wconfig (current-window-configuration)))
  483.     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
  484.  
  485. (defun hyper-where-is (symbol)
  486.   "Print message listing key sequences that invoke specified command."
  487.   (interactive (list (hyper-apropos-read-function-symbol "Where is function")))
  488.   (if (null symbol)
  489.       (message "Sorry, nothing to describe.")
  490.     (where-is symbol)))
  491.  
  492. ;;;###autoload
  493. (defun hyper-describe-function (symbol &optional this-ref-buffer)
  494.   "Hypertext replacement for `describe-function'.  Unlike `describe-function'
  495. in that the symbol under the cursor is the default if it is a function.
  496. See also `hyper-apropos' and `hyper-describe-variable'."
  497.   ;; #### - perhaps a prefix arg should suppress the prompt...
  498.   (interactive (list (hyper-apropos-read-function-symbol
  499.               (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
  500.               "Follow function"
  501.             "Describe function"))
  502.              current-prefix-arg))
  503.   (if (null symbol)
  504.       (message "Sorry, nothing to describe.")
  505.     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
  506.     (setq hyper-apropos-prev-wconfig (current-window-configuration)))
  507.     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
  508.  
  509. ;;;###autoload
  510. (defun hyper-apropos-read-variable-symbol (prompt &optional predicate)
  511.   "Hypertext drop-in replacement for `describe-variable'.
  512. See also `hyper-apropos' and `hyper-describe-function'."
  513.   ;; #### - perhaps a prefix arg should suppress the prompt...
  514.   (or predicate (setq predicate 'boundp))
  515.   (let (v val)
  516.     (setq v (hyper-apropos-this-symbol))    ; symbol under point
  517.     (or (funcall predicate v)
  518.     (setq v (variable-at-point)))
  519.     (or (funcall predicate v)
  520.     (setq v nil))
  521.     (setq val (let ((enable-recursive-minibuffers t))
  522.         (completing-read
  523.          (concat prompt
  524.              (if v
  525.                  (format " (default %s): " v)
  526.                ": "))
  527.          obarray predicate t nil 'variable-history)))
  528.     (if (string= val "")
  529.     (progn (push (symbol-name v) variable-history) v)
  530.       (intern-soft val))))
  531. ;;;###autoload
  532. (define-obsolete-function-alias
  533.   'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol)
  534.  
  535. (defun hyper-apropos-read-function-symbol (prompt)
  536.   "Read function symbol from minibuffer."
  537.   (let ((fn (hyper-apropos-this-symbol))
  538.     val)
  539.     (or (fboundp fn)
  540.     (setq fn (function-at-point)))
  541.     (setq val (let ((enable-recursive-minibuffers t))
  542.         (completing-read (if fn
  543.                      (format "%s (default %s): " prompt fn)
  544.                    (format "%s: " prompt))
  545.                  obarray 'fboundp t nil
  546.                  'function-history)))
  547.     (if (equal val "")
  548.     (progn (push (symbol-name fn) function-history) fn)
  549.       (intern-soft val))))
  550.  
  551. (defun hyper-apropos-last-help (arg)
  552.   "Go back to the last symbol documented in the *Hyper Help* buffer."
  553.   (interactive "P")
  554.   (let ((win (get-buffer-window hyper-apropos-help-buf)))
  555.     (or arg (setq arg (if win 1 0)))
  556.     (cond ((= arg 0))
  557.       ((<= (length hyper-apropos-help-history) arg)
  558.        ;; go back as far as we can...
  559.        (setcdr (nreverse hyper-apropos-help-history) nil))
  560.       (t
  561.        (setq hyper-apropos-help-history
  562.          (nthcdr arg hyper-apropos-help-history))))
  563.     (if (or win (> arg 0))
  564.     (hyper-apropos-get-doc (car hyper-apropos-help-history) t)
  565.       (display-buffer hyper-apropos-help-buf))))
  566.  
  567. (defun hyper-apropos-insert-face (string &optional face)
  568.   "Insert STRING and fontify some parts with face `hyper-apropos-hyperlink'."
  569.   (let ((beg (point)) end)
  570.     (insert-face string (or face 'hyper-apropos-documentation))
  571.     (setq end (point))
  572.     (goto-char beg)
  573.     (while (re-search-forward
  574.         "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
  575.         end 'limit)
  576.       (let ((e (make-extent (match-beginning 1) (match-end 1))))
  577.     (set-extent-face e 'hyper-apropos-hyperlink)
  578.     (set-extent-property e 'mouse-face 'highlight)))
  579.     (goto-char beg)
  580.     (while (re-search-forward
  581.         "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
  582.         end 'limit)
  583.       (let ((e (make-extent (match-beginning 1) (match-end 1))))
  584.     (set-extent-face e 'hyper-apropos-hyperlink)
  585.     (set-extent-property e 'mouse-face 'highlight)))))
  586.  
  587. (defun hyper-apropos-insert-keybinding (keys string)
  588.   (if keys
  589.       (insert "  (" string " bound to \""
  590.           (mapconcat 'key-description
  591.              (sort* keys #'< :key #'length)
  592.              "\", \"")
  593.           "\")\n")))
  594.  
  595. (defun hyper-apropos-insert-section-heading (alias-desc &optional desc)
  596.   (or desc (setq desc alias-desc
  597.          alias-desc nil))
  598.   (if alias-desc
  599.       (setq desc (concat alias-desc
  600.              (if (memq (aref desc 0)
  601.                    '(?a ?e ?i ?o ?u))
  602.                  ", an " ", a ")
  603.              desc)))
  604.   (aset desc 0 (upcase (aref desc 0))) ; capitalize
  605.   (goto-char (point-max))
  606.   (newline 3) (delete-blank-lines) (newline 2)
  607.   (hyper-apropos-insert-face desc 'hyper-apropos-section-heading))
  608.  
  609. (defun hyper-apropos-insert-value (string symbol val)
  610.   (insert-face string 'hyper-apropos-heading)
  611.   (insert (if (symbol-value symbol)
  612.           (if (or (null val) (eq val t) (integerp val))
  613.           (prog1
  614.               (symbol-value symbol)
  615.             (set symbol nil))
  616.         "see below")
  617.         "is void")))
  618.  
  619. (defun hyper-apropos-follow-ref-buffer (this-ref-buffer) 
  620.   (and (not this-ref-buffer)
  621.        (eq major-mode 'hyper-apropos-help-mode)
  622.        hyper-apropos-ref-buffer
  623.        (buffer-live-p hyper-apropos-ref-buffer)))
  624.  
  625. (defun hyper-apropos-get-alias (symbol alias-p next-symbol &optional use)
  626.   "Return (TERMINAL-SYMBOL . ALIAS-DESC)."
  627.   (let (aliases)
  628.     (while (funcall alias-p symbol)
  629.       (setq aliases (cons (if use (funcall use symbol) symbol) aliases))
  630.       (setq symbol (funcall next-symbol symbol)))
  631.     (cons symbol
  632.       (and aliases
  633.            (concat "an alias for `"
  634.                (mapconcat 'symbol-name
  635.                   (nreverse aliases)
  636.                   "',\nwhich is an alias for `")
  637.                "'")))))
  638.  
  639. (defun hyper-apropos-get-doc (&optional symbol force type this-ref-buffer)
  640.   ;; #### - update this docstring
  641.   "Toggle display of documentation for the symbol on the current line."
  642.   ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
  643.   ;; regenerate the documentation even if it already seems to be there.  And
  644.   ;; TYPE, if present, forces the generation of only variable documentation
  645.   ;; or only function documentation.  Normally, if both are present, then
  646.   ;; both will be generated.
  647.   ;;
  648.   ;; TYPES TO IMPLEMENT: obsolete face
  649.   ;;
  650.   (interactive)
  651.   (or symbol
  652.       (setq symbol (hyper-apropos-this-symbol)))
  653.   (or type
  654.       (setq type '(function variable face)))
  655.   (if (and (eq hyper-apropos-currently-showing symbol)
  656.        (get-buffer hyper-apropos-help-buf)
  657.        (get-buffer-window hyper-apropos-help-buf)
  658.        (not force))
  659.       ;; we're already displaying this help, so toggle its display.
  660.       (delete-windows-on hyper-apropos-help-buf)
  661.     ;; OK, we've got to refresh and display it...
  662.     (or (eq symbol (car hyper-apropos-help-history))
  663.     (setq hyper-apropos-help-history
  664.           (if (eq major-mode 'hyper-apropos-help-mode)
  665.           ;; if we're following a link in the help buffer, then
  666.           ;; record that in the help history.
  667.           (cons symbol hyper-apropos-help-history)
  668.         ;; otherwise clear the history because it's a new search.
  669.         (list symbol))))
  670.     (save-excursion
  671.       (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
  672.       (set-buffer hyper-apropos-ref-buffer)
  673.     (setq hyper-apropos-ref-buffer (current-buffer)))
  674.       (let (standard-output
  675.         ok beg
  676.         newsym symtype doc obsolete
  677.         (local mode-name)
  678.         global local-str global-str
  679.         font fore back undl
  680.         aliases alias-desc desc)
  681.     (save-excursion
  682.       (set-buffer (get-buffer-create hyper-apropos-help-buf))
  683.       ;;(setq standard-output (current-buffer))
  684.       (setq buffer-read-only nil)
  685.       (erase-buffer)
  686.       (insert-face (format "`%s'" symbol) 'hyper-apropos-major-heading)
  687.       (insert (format " (buffer: %s, mode: %s)\n"
  688.               (buffer-name hyper-apropos-ref-buffer)
  689.               local)))
  690.     ;; function ----------------------------------------------------------
  691.     (and (memq 'function type)
  692.          (fboundp symbol)
  693.          (progn
  694.            (setq ok t)
  695.            (setq aliases (hyper-apropos-get-alias (symbol-function symbol)
  696.                          'symbolp
  697.                          'symbol-function)
  698.              newsym (car aliases)
  699.              alias-desc (cdr aliases))
  700.            (if (eq 'macro (car-safe newsym))
  701.            (setq desc "macro"
  702.              newsym (cdr newsym))
  703.          (setq desc "function"))
  704.            (setq symtype (cond ((subrp newsym)                   'subr)
  705.                    ((compiled-function-p newsym)     'bytecode)
  706.                    ((eq (car-safe newsym) 'autoload) 'autoload)
  707.                    ((eq (car-safe newsym) 'lambda)   'lambda))
  708.              desc (concat (if (commandp symbol) "interactive ")
  709.                   (cdr (assq symtype
  710.                          '((subr     . "built-in ")
  711.                            (bytecode . "compiled Lisp ")
  712.                            (autoload . "autoloaded Lisp ")
  713.                            (lambda   . "Lisp "))))
  714.                   desc
  715.                   (if (eq symtype 'autoload)
  716.                       (format ", (autoloaded from \"%s\")"
  717.                       (nth 1 newsym))))
  718.              local (current-local-map)
  719.              global (current-global-map)
  720.              obsolete (get symbol 'byte-obsolete-info)
  721.              doc (or (documentation symbol) "function not documented"))
  722.            (save-excursion
  723.          (set-buffer hyper-apropos-help-buf)
  724.          (goto-char (point-max))
  725.          (setq standard-output (current-buffer))
  726.          (hyper-apropos-insert-section-heading alias-desc desc)
  727.          (insert ":\n")
  728.          (if local
  729.              (hyper-apropos-insert-keybinding
  730.               (where-is-internal symbol (list local) nil nil nil)
  731.               "locally"))
  732.          (hyper-apropos-insert-keybinding
  733.           (where-is-internal symbol (list global) nil nil nil)
  734.           "globally")
  735.          (insert "\n")
  736.          (if obsolete
  737.              (hyper-apropos-insert-face
  738.               (format "%s is an obsolete function; %s\n\n" symbol
  739.                   (if (stringp (car obsolete))
  740.                   (car obsolete)
  741.                 (format "use `%s' instead." (car obsolete))))
  742.               'hyper-apropos-warning))
  743.          (setq beg (point))
  744.          (insert-face "arguments: " 'hyper-apropos-heading)
  745.          (cond ((eq symtype 'lambda)
  746.             (princ (or (nth 1 newsym) "()")))
  747.                ((eq symtype 'bytecode)
  748.             (princ (or (compiled-function-arglist newsym)
  749.                    "()")))
  750.                ((and (eq symtype 'subr)
  751.                  (string-match
  752.                   "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
  753.                   doc))
  754.             (insert (substring doc
  755.                        (match-beginning 1)
  756.                        (match-end 1)))
  757.             (setq doc (substring doc 0 (match-beginning 0))))
  758.                ((and (eq symtype 'subr)
  759.                  (string-match
  760.                   "\
  761. \[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
  762.                   doc))
  763.             (insert "("
  764.                 (if (match-end 1)
  765.                     (substring doc
  766.                            (match-beginning 1)
  767.                            (match-end 1)))
  768.                 ")")
  769.             (setq doc (substring doc (match-end 0))))
  770.                (t (princ "[not available]")))
  771.          (insert "\n\n")
  772.          (hyper-apropos-insert-face doc)
  773.          (insert "\n")
  774.          (indent-rigidly beg (point) 2))))
  775.     ;; variable ----------------------------------------------------------
  776.     (and (memq 'variable type)
  777.          (or (boundp symbol) (default-boundp symbol))
  778.          (progn 
  779.            (setq ok t)
  780.            (setq aliases (hyper-apropos-get-alias symbol
  781.                          'variable-alias
  782.                          'variable-alias
  783.                          'variable-alias)
  784.              newsym (car aliases)
  785.              alias-desc (cdr aliases))
  786.            (setq symtype (or (local-variable-p newsym (current-buffer))
  787.                  (and (local-variable-p newsym
  788.                             (current-buffer) t)
  789.                       'auto-local))
  790.              desc (concat (and (get newsym 'custom-type)
  791.                        "customizable ")
  792.                   (if (user-variable-p newsym)
  793.                       "user variable"
  794.                     "variable")
  795.                   (cond ((eq symtype t) ", buffer-local")
  796.                     ((eq symtype 'auto-local)
  797.                      ", local when set")))
  798.              local (and (boundp newsym)
  799.                 (symbol-value newsym))
  800.              local-str (and (boundp newsym)
  801.                     (prin1-to-string local))
  802.              global (and (eq symtype t)
  803.                  (default-boundp newsym)
  804.                  (default-value newsym))
  805.              global-str (and (eq symtype t)
  806.                      (default-boundp newsym)
  807.                      (prin1-to-string global))
  808.              obsolete (get symbol 'byte-obsolete-variable)
  809.              doc (or (documentation-property symbol
  810.                              'variable-documentation)
  811.                  "variable not documented"))
  812.            (save-excursion
  813.          (set-buffer hyper-apropos-help-buf)
  814.          (goto-char (point-max))
  815.          (setq standard-output (current-buffer))
  816.          (hyper-apropos-insert-section-heading alias-desc desc)
  817.          (when (and (user-variable-p newsym)
  818.                 (get newsym 'custom-type))
  819.            (let ((e (make-extent (point-at-bol) (point))))
  820.              (set-extent-property e 'mouse-face 'highlight)
  821.              (set-extent-property e 'help-echo
  822.                       (format "Customize %s" newsym))
  823.              (set-extent-property
  824.               e 'hyper-apropos-custom
  825.               `(lambda () (customize-variable (quote ,newsym))))))
  826.          (insert ":\n\n")
  827.          (setq beg (point))
  828.          (if obsolete
  829.              (hyper-apropos-insert-face
  830.               (format "%s is an obsolete function; %s\n\n" symbol
  831.                   (if (stringp obsolete)
  832.                   obsolete
  833.                 (format "use `%s' instead." obsolete)))
  834.               'hyper-apropos-warning))
  835.          ;; generally, the value of the variable is short and the
  836.          ;; documentation of the variable long, so it's desirable
  837.          ;; to see all of the value and the start of the
  838.          ;; documentation.  Some variables, though, have huge and
  839.          ;; nearly meaningless values that force you to page
  840.          ;; forward just to find the doc string.  That is
  841.          ;; undesirable.
  842.          (if (and (or (null local-str) (< (length local-str) 69))
  843.               (or (null global-str) (< (length global-str) 69)))
  844.                     ; 80 cols.  docstrings assume this.
  845.              (progn (insert-face "value: " 'hyper-apropos-heading)
  846.                 (insert (or local-str "is void"))
  847.                 (if (eq symtype t)
  848.                 (progn
  849.                   (insert "\n")
  850.                   (insert-face "default value: " 'hyper-apropos-heading)
  851.                   (insert (or global-str "is void"))))
  852.                 (insert "\n\n")
  853.                 (hyper-apropos-insert-face doc))
  854.            (hyper-apropos-insert-value "value: " 'local-str local)
  855.            (if (eq symtype t)
  856.                (progn
  857.              (insert ", ")
  858.              (hyper-apropos-insert-value "default-value: "
  859.                         'global-str global)))
  860.            (insert "\n\n")
  861.            (hyper-apropos-insert-face doc)
  862.            (if local-str
  863.                (progn
  864.              (newline 3) (delete-blank-lines) (newline 1)
  865.              (insert-face "value: " 'hyper-apropos-heading)
  866.              (if hyper-apropos-prettyprint-long-values
  867.                  (condition-case nil
  868.                  (let ((pp-print-readably nil)) (pprint local))
  869.                    (error (insert local-str)))
  870.                (insert local-str))))
  871.            (if global-str
  872.                (progn
  873.              (newline 3) (delete-blank-lines) (newline 1)
  874.              (insert-face "default value: " 'hyper-apropos-heading)
  875.              (if hyper-apropos-prettyprint-long-values
  876.                  (condition-case nil
  877.                  (let ((pp-print-readably nil)) (pprint global))
  878.                    (error (insert global-str)))
  879.                (insert global-str)))))
  880.          (indent-rigidly beg (point) 2))))
  881.     ;; face --------------------------------------------------------------
  882.     (and (memq 'face type)
  883.          (find-face symbol)
  884.          (progn
  885.            (setq ok t)
  886.            (copy-face symbol 'hyper-apropos-temp-face 'global)
  887.            (mapcar (function
  888.             (lambda (property)
  889.               (setq symtype (face-property-instance symbol
  890.                                 property))
  891.               (if symtype
  892.                   (set-face-property 'hyper-apropos-temp-face
  893.                          property
  894.                          symtype))))
  895.                built-in-face-specifiers)
  896.            (setq font (cons (face-property-instance symbol 'font nil 0 t)
  897.                 (face-property-instance symbol 'font))
  898.              fore (cons (face-foreground-instance symbol nil 0 t)
  899.                 (face-foreground-instance symbol))
  900.              back (cons (face-background-instance symbol nil 0 t)
  901.                 (face-background-instance symbol))
  902.              undl (cons (face-underline-p symbol nil 0 t)
  903.                 (face-underline-p symbol))
  904.              doc  (face-doc-string symbol))
  905.            ;; #### - add some code here
  906.            (save-excursion
  907.          (set-buffer hyper-apropos-help-buf)
  908.          (setq standard-output (current-buffer))
  909.          (hyper-apropos-insert-section-heading
  910.           (concat "Face"
  911.               (when (get symbol 'face-defface-spec)
  912.                 (let* ((str " (customizable)")
  913.                    (e (make-extent 1 (length str) str)))
  914.                   (set-extent-property e 'mouse-face 'highlight)
  915.                   (set-extent-property e 'help-echo
  916.                            (format "Customize %s" symbol))
  917.                   (set-extent-property e 'unique t)
  918.                   (set-extent-property e 'duplicable t)
  919.                   (set-extent-property
  920.                    e 'hyper-apropos-custom
  921.                    `(lambda () (customize-face (quote ,symbol))))
  922.                   str))
  923.               ":\n\n  "))
  924.          (insert-face "\
  925. ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
  926.                   'hyper-apropos-temp-face)
  927.          (newline 2)
  928.          (insert-face "  Font: " 'hyper-apropos-heading)
  929.          (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
  930.                  (and (cdr font)
  931.                       (font-instance-name (cdr font)))))
  932.          (insert-face "  Foreground: " 'hyper-apropos-heading)
  933.          (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
  934.                  (and (cdr fore)
  935.                       (color-instance-name (cdr fore)))))
  936.          (insert-face "  Background: " 'hyper-apropos-heading)
  937.          (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
  938.                  (and (cdr back)
  939.                       (color-instance-name (cdr back)))))
  940.          (insert-face "  Underline: " 'hyper-apropos-heading)
  941.          (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
  942.                  (cdr undl)))
  943.          (if doc
  944.              (progn
  945.                (newline)
  946.                (setq beg (point))
  947.                (insert doc)
  948.                (indent-rigidly beg (point) 2))))))
  949.     ;; not bound & property list -----------------------------------------
  950.     (or ok
  951.         (save-excursion
  952.           (set-buffer hyper-apropos-help-buf)
  953.           (hyper-apropos-insert-section-heading
  954.            "symbol is not currently bound\n")))
  955.     (if (and (setq symtype (symbol-plist symbol))
  956.          (or (> (length symtype) 2)
  957.              (not (memq 'variable-documentation symtype))))
  958.         (save-excursion
  959.           (set-buffer hyper-apropos-help-buf)
  960.           (goto-char (point-max))
  961.           (setq standard-output (current-buffer))
  962.           (hyper-apropos-insert-section-heading "property-list:\n\n")
  963.           (while symtype
  964.         (if (memq (car symtype)
  965.               '(variable-documentation byte-obsolete-info))
  966.             (setq symtype (cdr symtype))
  967.           (insert-face (concat "  " (symbol-name (car symtype))
  968.                        ": ")
  969.                    'hyper-apropos-heading)
  970.           (setq symtype (cdr symtype))
  971.           (indent-to 32)
  972.           (insert (prin1-to-string (car symtype)) "\n"))
  973.         (setq symtype (cdr symtype)))))))
  974.     (save-excursion
  975.       (set-buffer hyper-apropos-help-buf)
  976.       (goto-char (point-min)) 
  977.       ;; pop up window and shrink it if it's wasting space
  978.       (if hyper-apropos-shrink-window
  979.       (shrink-window-if-larger-than-buffer
  980.        (display-buffer (current-buffer)))
  981.     (display-buffer (current-buffer)))
  982.       (hyper-apropos-help-mode))
  983.     (setq hyper-apropos-currently-showing symbol)))
  984. ;;;###autoload
  985. (define-obsolete-function-alias
  986.   'hypropos-get-doc 'hyper-apropos-get-doc)
  987.  
  988. ; -----------------------------------------------------------------------------
  989.  
  990. (defun hyper-apropos-help-mode ()
  991.   "Major mode for hypertext XEmacs help.  In this mode, you can quickly
  992. follow links between back and forth between the documentation strings for
  993. different variables and functions.  Common commands:
  994.  
  995. \\{hyper-apropos-help-map}"
  996.   (setq buffer-read-only t
  997.     major-mode         'hyper-apropos-help-mode
  998.     mode-name         "Hyper-Help")
  999.   (set-syntax-table emacs-lisp-mode-syntax-table)
  1000.   (use-local-map hyper-apropos-help-map))
  1001.  
  1002. ;; ---------------------------------------------------------------------- ;;
  1003.  
  1004. (defun hyper-apropos-scroll-up ()
  1005.   "Scroll up the \"*Hyper Help*\" buffer if it's visible.
  1006. Otherwise, scroll the selected window up."
  1007.   (interactive)
  1008.   (let ((win (get-buffer-window hyper-apropos-help-buf))
  1009.     (owin (selected-window)))
  1010.     (if win
  1011.     (progn
  1012.       (select-window win)
  1013.       (condition-case nil
  1014.            (scroll-up nil)
  1015.           (error (goto-char (point-max))))
  1016.       (select-window owin))
  1017.       (scroll-up nil))))
  1018.  
  1019. (defun hyper-apropos-scroll-down ()
  1020.   "Scroll down the \"*Hyper Help*\" buffer if it's visible.
  1021. Otherwise, scroll the selected window down."
  1022.   (interactive)
  1023.   (let ((win (get-buffer-window hyper-apropos-help-buf))
  1024.     (owin (selected-window)))
  1025.     (if win
  1026.     (progn
  1027.       (select-window win)
  1028.       (condition-case nil
  1029.            (scroll-down nil)
  1030.           (error (goto-char (point-max))))
  1031.       (select-window owin))
  1032.       (scroll-down nil))))
  1033.  
  1034. ;; ---------------------------------------------------------------------- ;;
  1035.  
  1036. (defun hyper-apropos-mouse-get-doc (event)
  1037.   "Get the documentation for the symbol the mouse is on."
  1038.   (interactive "e")
  1039.   (mouse-set-point event)
  1040.   (let ((e (extent-at (point) nil 'hyper-apropos-custom)))
  1041.     (if e
  1042.     (funcall (extent-property e 'hyper-apropos-custom))
  1043.       (save-excursion
  1044.     (let ((symbol (hyper-apropos-this-symbol)))
  1045.       (if symbol
  1046.           (hyper-apropos-get-doc symbol)
  1047.         (error "Click on a symbol")))))))
  1048.  
  1049. ;; ---------------------------------------------------------------------- ;;
  1050.  
  1051. (defun hyper-apropos-add-keyword (pattern)
  1052.   "Use additional keyword to narrow regexp match.
  1053. Deletes lines which don't match PATTERN."
  1054.   (interactive "sAdditional Keyword: ")
  1055.   (save-excursion
  1056.     (goto-char (point-min))
  1057.     (let (buffer-read-only)
  1058.       (keep-lines (concat pattern "\\|" hyper-apropos-junk-regexp))
  1059.       )))
  1060.  
  1061. (defun hyper-apropos-eliminate-keyword (pattern)
  1062.   "Use additional keyword to eliminate uninteresting matches.
  1063. Deletes lines which match PATTERN."
  1064.   (interactive "sKeyword to eliminate: ")
  1065.   (save-excursion
  1066.     (goto-char (point-min))
  1067.     (let (buffer-read-only)
  1068.       (flush-lines pattern))
  1069.       ))
  1070.  
  1071. ;; ---------------------------------------------------------------------- ;;
  1072.  
  1073. (defun hyper-apropos-this-symbol ()
  1074.   (save-excursion
  1075.     (cond ((eq major-mode 'hyper-apropos-mode)
  1076.        (beginning-of-line)
  1077.        (if (looking-at hyper-apropos-junk-regexp)
  1078.            nil
  1079.          (forward-char 3)
  1080.          (read (point-marker))))
  1081.       (t
  1082.        (let* ((st (progn
  1083.             (skip-syntax-backward "w_")
  1084.             ;; !@(*$^%%# stupid backquote implementation!!!
  1085.             (skip-chars-forward "`")
  1086.             (point)))
  1087.           (en (progn
  1088.             (skip-syntax-forward "w_")
  1089.             (skip-chars-backward ".':") ; : for Local Variables
  1090.             (point))))
  1091.          (and (not (eq st en))
  1092.           (intern-soft (buffer-substring st en))))))))
  1093.  
  1094. (defun hyper-apropos-where-is (symbol)
  1095.   "Find keybinding for symbol on current line."
  1096.   (interactive (list (hyper-apropos-this-symbol)))
  1097.   (where-is symbol))
  1098.  
  1099. (defun hyper-apropos-invoke-fn (fn)
  1100.   "Interactively invoke the function on the current line."
  1101.   (interactive (list (hyper-apropos-this-symbol)))
  1102.   (cond ((not (fboundp fn))
  1103.      (error "%S is not a function" fn))
  1104.     (t (call-interactively fn))))
  1105.  
  1106. ;;;###autoload
  1107. (defun hyper-set-variable (var val &optional this-ref-buffer)
  1108.   (interactive
  1109.    (let ((var (hyper-apropos-read-variable-symbol
  1110.            (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
  1111.            "In ref buffer, set user option"
  1112.          "Set user option")
  1113.            'user-variable-p)))
  1114.      (list var (hyper-apropos-read-variable-value var) current-prefix-arg)))
  1115.   (hyper-apropos-set-variable var val this-ref-buffer))
  1116.  
  1117. ;;;###autoload
  1118. (defun hyper-apropos-set-variable (var val &optional this-ref-buffer)
  1119.   "Interactively set the variable on the current line."
  1120.   (interactive
  1121.    (let ((var (hyper-apropos-this-symbol)))
  1122.      (or (and var (boundp var))
  1123.      (and (setq var (and (eq major-mode 'hyper-apropos-help-mode)
  1124.                  (save-excursion
  1125.                    (goto-char (point-min))
  1126.                    (hyper-apropos-this-symbol))))
  1127.           (boundp var))
  1128.      (setq var nil))
  1129.      (list var (hyper-apropos-read-variable-value var))))
  1130.   (and var
  1131.        (boundp var)
  1132.        (progn
  1133.      (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
  1134.          (save-excursion
  1135.            (set-buffer hyper-apropos-ref-buffer)
  1136.            (set var val))
  1137.        (set var val))
  1138.      (hyper-apropos-get-doc var t '(variable) this-ref-buffer))))
  1139. ;;;###autoload
  1140. (define-obsolete-function-alias
  1141.   'hypropos-set-variable 'hyper-apropos-set-variable)
  1142.  
  1143. (defun hyper-apropos-read-variable-value (var &optional this-ref-buffer)
  1144.   (and var
  1145.        (boundp var)
  1146.        (let ((prop (get var 'variable-interactive))
  1147.          (print-readably t)
  1148.          val str)
  1149.      (hyper-apropos-get-doc var t '(variable) current-prefix-arg)
  1150.      (if prop
  1151.          (call-interactively (list 'lambda '(arg)
  1152.                        (list 'interactive prop)
  1153.                        'arg))
  1154.        (setq val (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
  1155.              (save-excursion
  1156.                (set-buffer hyper-apropos-ref-buffer)
  1157.                (symbol-value var))
  1158.                (symbol-value var))
  1159.          str (prin1-to-string val))
  1160.        (eval-minibuffer
  1161.         (format "Set %s `%s' to value (evaluated): "
  1162.             (if (user-variable-p var) "user option" "Variable")
  1163.             var)
  1164.         (condition-case nil
  1165.         (progn
  1166.           (read str)
  1167.           (format (if (or (consp val)
  1168.                   (and (symbolp val)
  1169.                        (not (memq val '(t nil)))))
  1170.                   "'%s" "%s")
  1171.               str))
  1172.           (error nil)))))))
  1173.  
  1174. (defun hyper-apropos-customize-variable ()
  1175.   (interactive)
  1176.   (let ((var (hyper-apropos-this-symbol)))
  1177.     (customize-variable var)))
  1178.  
  1179. ;; ---------------------------------------------------------------------- ;;
  1180.  
  1181. (defun hyper-apropos-find-tag (&optional tag-name)
  1182.   "Find the tag for the symbol on the current line in other window.  In
  1183. order for this to work properly, the variable `tag-table-alist' or
  1184. `tags-file-name' must be set so that a TAGS file with tags for the emacs
  1185. source is found for the \"*Hyper Apropos*\" buffer."
  1186.   (interactive)
  1187.   ;; there ought to be a default tags file for this...
  1188.   (or tag-name (setq tag-name (symbol-name (hyper-apropos-this-symbol))))
  1189.   (find-tag-other-window (list tag-name)))
  1190.  
  1191. ;; ---------------------------------------------------------------------- ;;
  1192.  
  1193. (defun hyper-apropos-find-function (fn)
  1194.   "Find the function for the symbol on the current line in other
  1195. window.  (See also `find-function'.)"
  1196.   (interactive
  1197.    (let ((fn (hyper-apropos-this-symbol)))
  1198.      (or (fboundp fn)
  1199.      (and (setq fn (and (eq major-mode 'hyper-apropos-help-mode)
  1200.                 (save-excursion
  1201.                   (goto-char (point-min))
  1202.                   (hyper-apropos-this-symbol))))
  1203.           (fboundp fn))
  1204.      (setq fn nil))
  1205.      (list fn)))
  1206.   (if fn
  1207.       (find-function-other-window fn)))
  1208.  
  1209. ;; ---------------------------------------------------------------------- ;;
  1210.  
  1211. (defun hyper-apropos-disassemble (sym)
  1212.   "Disassemble FUN if it is byte-coded.  If it's a lambda, prettyprint it."
  1213.   (interactive (list (hyper-apropos-this-symbol)))
  1214.   (let ((fun sym) (trail nil) macrop)
  1215.     (while (and (symbolp fun) (not (memq fun trail)))
  1216.       (setq trail (cons fun trail)
  1217.         fun (symbol-function fun)))
  1218.     (and (symbolp fun)
  1219.      (error "Loop detected in function binding of `%s'" fun))
  1220.     (setq macrop (and  (consp fun)
  1221.                (eq 'macro (car fun))))
  1222.     (cond ((compiled-function-p (if macrop (cdr fun) fun))
  1223.        (disassemble fun)
  1224.        (set-buffer "*Disassemble*")
  1225.        (goto-char (point-min))
  1226.        (forward-sexp 2)
  1227.        (insert (format " for function `%S'" sym))
  1228.        )
  1229.       ((consp fun)
  1230.        (with-output-to-temp-buffer "*Disassemble*"
  1231.          (pprint (if macrop
  1232.              (cons 'defmacro (cons sym (cdr (cdr fun))))
  1233.                (cons 'defun (cons sym (cdr fun))))))
  1234.        (set-buffer "*Disassemble*")
  1235.        (emacs-lisp-mode))
  1236.       ((or (vectorp fun) (stringp fun))
  1237.        ;; #### - do something fancy here
  1238.        (with-output-to-temp-buffer "*Disassemble*"
  1239.          (princ (format "%s is a keyboard macro:\n\n\t" sym))
  1240.          (prin1 fun)))
  1241.       (t
  1242.        (error "Sorry, cannot disassemble `%s'" sym)))))
  1243.  
  1244. ;; ---------------------------------------------------------------------- ;;
  1245.  
  1246. (defun hyper-apropos-quit ()
  1247.   (interactive)
  1248.   "Quit Hyper Apropos and restore original window config."
  1249.   (let ((buf (get-buffer hyper-apropos-apropos-buf)))
  1250.     (and buf (bury-buffer buf)))
  1251.   (set-window-configuration hyper-apropos-prev-wconfig))
  1252.  
  1253. ;; ---------------------------------------------------------------------- ;;
  1254.  
  1255. ;;;###autoload
  1256. (defun hyper-apropos-popup-menu (event)
  1257.   (interactive "e")
  1258.   (mouse-set-point event)
  1259.   (let* ((sym (or (hyper-apropos-this-symbol)
  1260.           (and (eq major-mode 'hyper-apropos-help-mode)
  1261.                (save-excursion
  1262.              (goto-char (point-min))
  1263.              (hyper-apropos-this-symbol)))))
  1264.      (notjunk (not (null sym)))
  1265.      (command-p (if (commandp sym) t))
  1266.      (variable-p (and sym (boundp sym)))
  1267.      (customizable-p (and variable-p
  1268.                   (get sym 'custom-type)
  1269.                   t))
  1270.      (function-p (fboundp sym))
  1271.      (apropos-p (eq 'hyper-apropos-mode
  1272.             (save-excursion (set-buffer (event-buffer event))
  1273.                     major-mode)))
  1274.      (name (if sym (symbol-name sym) ""))
  1275.      (hyper-apropos-menu
  1276.       (delete
  1277.        nil
  1278.        (list (concat "Hyper-Help: " name)
  1279.         (vector "Display documentation" 'hyper-apropos-get-doc   notjunk)
  1280.         (vector "Set variable"    'hyper-apropos-set-variable variable-p)
  1281.         (vector "Customize variable" 'hyper-apropos-customize-variable
  1282.             customizable-p)
  1283.         (vector "Show keys for"     'hyper-apropos-where-is      command-p)
  1284.         (vector "Invoke command"    'hyper-apropos-invoke-fn     command-p)
  1285.         (vector "Find function"    'hyper-apropos-find-function function-p)
  1286.         (vector "Find tag"        'hyper-apropos-find-tag    notjunk)
  1287.         (and apropos-p
  1288.          ["Add keyword..." hyper-apropos-add-keyword    t])
  1289.         (and apropos-p
  1290.          ["Eliminate keyword..." hyper-apropos-eliminate-keyword  t])
  1291.         (if apropos-p
  1292.         ["Programmers' Apropos" hyper-apropos-toggle-programming-flag
  1293.          :style toggle :selected hyper-apropos-programming-apropos]
  1294.           ["Programmers' Help" hyper-apropos-toggle-programming-flag
  1295.            :style toggle :selected hyper-apropos-programming-apropos])
  1296.         (and hyper-apropos-programming-apropos
  1297.          (vector "Disassemble function"
  1298.              'hyper-apropos-disassemble
  1299.              function-p))
  1300.         ["Help"                     describe-mode           t]
  1301.         ["Quit"            hyper-apropos-quit        t]
  1302.         ))))
  1303.     (popup-menu hyper-apropos-menu)))
  1304. ;;;###autoload
  1305. (define-obsolete-function-alias
  1306.   'hypropos-popup-menu 'hyper-apropos-popup-menu)
  1307.  
  1308. (provide 'hyper-apropos)
  1309.  
  1310. ;; end of hyper-apropos.el
  1311.